home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacQForth 1.0 / code / intmath.4th < prev    next >
Encoding:
Text File  |  1995-03-29  |  2.5 KB  |  76 lines  |  [TEXT/ALFA]
  1. ( Integer math routines for 16-bit MacQForth  )
  2.  
  3. ( RTK - 03.15.95 )
  4.  
  5. ( -------------------------------------------------------------------------- )
  6.  
  7. ( Integer arithmetic scaling, uses a 32-bit multiply )
  8.  
  9. : */  ( a b c --  a*b/c )  65392 execute ;  ( $FF70 )
  10.  
  11. ( All arithmetic scaled by 10000 )
  12.  
  13. : pi ( -- pi*10000 )  31415 ;
  14.  
  15. ( Basic trig*10000 )
  16.  
  17. ( These routines from Pocket Forth 6.3 by Chris Heilman, INTEGERTRIG file )
  18.  
  19. create sinTable  ( a table of sin*10000, angles from 0 to 90 degrees )
  20.     
  21.     00000 ,
  22.     00175 , 00349 , 00524 , 00698 , 00872 , 01045 , 01219 , 01392 ,
  23.     01571 , 01736 , 01908 , 02079 , 02250 , 02419 , 02588 , 02756 ,
  24.     02924 , 03090 , 03256 , 03420 , 03584 , 03746 , 03907 , 04067 ,
  25.     04226 , 04384 , 04540 , 04695 , 04848 , 05000 , 05150 , 05299 ,
  26.     05446 , 05592 , 05736 , 05878 , 06018 , 06157 , 06293 , 06428 ,
  27.     06561 , 06691 , 06820 , 06947 , 07071 , 07193 , 07314 , 07431 ,
  28.     07547 , 07660 , 07771 , 07880 , 07986 , 08090 , 08192 , 08290 ,
  29.     08387 , 08480 , 08572 , 08660 , 08746 , 08829 , 08910 , 08988 ,
  30.     09063 , 09135 , 09205 , 09272 , 09336 , 09397 , 09455 , 09511 ,
  31.     09563 , 09613 , 09659 , 09703 , 09744 , 09781 , 09816 , 09848 ,
  32.     09877 , 09903 , 09925 , 09945 , 09962 , 09976 , 09986 , 09994 ,
  33.     09998 , 10000 ,
  34.  
  35. : ?negate ( make n positive ) if negate else then ;
  36. : fixangle ( map angle to -180 to 180 range )
  37.     dup abs  begin  dup 180 > while  360 - repeat
  38.     swap 0< ?negate ;
  39.  
  40. : sin ( degrees -- sin*10000 ) ( -180 <= angle <= 180 )
  41.     fixangle dup 0< >r  abs  dup 90 > if  180 swap - else then
  42.       2* sinTable + @  r> ?negate ;
  43. : cos ( degrees -- cos*10000 )
  44.     dup 0< if 90 + sin  else  90 - sin negate then ;
  45. : arcsin ( sine*10000 -- degrees )
  46.     dup 0< >r  abs  ( save sign )
  47.       91 0 do  ( check all angles )
  48.         dup i 2* sinTable + @ > 0= if  ( if sin>table value )
  49.         drop i  leave else then  loop 1-
  50.     r> ?negate ; ( restore sign )
  51.  
  52. ( additions by RTK )
  53.  
  54. : tan ( degrees -- tan*10000 ) 10000 swap dup sin swap cos */ ;
  55.  
  56. ( **2, **3, and ** )
  57.  
  58. variable _x
  59.  
  60. : **2  dup * ;         ( square )
  61. : **3  dup dup  * * ;  ( cube   )
  62.  
  63. : **  ( x y -- ) ( raise x to the y power )
  64.    _y ! _x !  _y @ 0= if 1 else 1  _y @ 0 do  _x @ *  loop  then  ;
  65.  
  66. : .frac  ( n d -- )  swap . 8 emit 47 emit  .  ; ( print a fraction n/d )
  67.  
  68. : 2hex ( n -- )  ( print as a hex number )
  69.    areg ! 64986 execute ;
  70.  
  71. : .hex ( n d -- )  ( print n as a d digit hex number, d is either 2 or 4 )
  72.    swap _x ! 2 = if  _x c@ 2hex  else  _x 1+ c@ 2hex _x c@ 2hex  then  ;
  73.  
  74. : 4hex  4 .hex  ;
  75.  
  76.